home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gnu / adainc / s-imgllb.adb < prev    next >
Text File  |  1996-01-30  |  5KB  |  151 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                       S Y S T E M . I M G _ L L B                        --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.4 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with System.Unsigned_Types; use System.Unsigned_Types;
  27.  
  28. package body System.Img_LLB is
  29.  
  30.    ---------------------------------------
  31.    -- Set_Image_Based_Long_Long_Integer --
  32.    ---------------------------------------
  33.  
  34.    procedure Set_Image_Based_Long_Long_Integer
  35.      (V : Long_Long_Integer;
  36.       B : Natural;
  37.       W : Integer;
  38.       S : out String;
  39.       P : in out Natural)
  40.    is
  41.       Start : Natural;
  42.  
  43.    begin
  44.       --  Positive case can just use the unsigned circuit directly
  45.  
  46.       if V >= 0 then
  47.          Set_Image_Based_Long_Long_Unsigned
  48.            (Long_Long_Unsigned (V), B, W, S, P);
  49.  
  50.       --  Negative case has to set a minus sign. Note also that we have to be
  51.       --  careful not to generate overflow with the largest negative number.
  52.  
  53.       else
  54.          P := P + 1;
  55.          S (P) := ' ';
  56.          Start := P;
  57.  
  58.          begin
  59.             pragma Suppress (Overflow_Check);
  60.             pragma Suppress (Range_Check);
  61.             Set_Image_Based_Long_Long_Unsigned
  62.               (Long_Long_Unsigned (-V), B, W - 1, S, P);
  63.          end;
  64.  
  65.          --  Set minus sign in last leading blank location. Because of the
  66.          --  code above, there must be at least one such location.
  67.  
  68.          while S (Start + 1) = ' ' loop
  69.             Start := Start + 1;
  70.          end loop;
  71.  
  72.          S (Start) := '-';
  73.       end if;
  74.  
  75.    end Set_Image_Based_Long_Long_Integer;
  76.  
  77.    ----------------------------------------
  78.    -- Set_Image_Based_Long_Long_Unsigned --
  79.    ----------------------------------------
  80.  
  81.    procedure Set_Image_Based_Long_Long_Unsigned
  82.      (V : Long_Long_Unsigned;
  83.       B : Natural;
  84.       W : Integer;
  85.       S : out String;
  86.       P : in out Natural)
  87.    is
  88.       Start : constant Natural := P;
  89.       F, T  : Natural;
  90.       BU    : constant Long_Long_Unsigned := Long_Long_Unsigned (B);
  91.       Hex   : constant array
  92.                 (Long_Long_Unsigned range 0 .. 15) of Character :=
  93.                                                          "0123456789ABCDEF";
  94.  
  95.       procedure Set_Digits (T : Long_Long_Unsigned);
  96.       --  Set digits of absolute value of T
  97.  
  98.       procedure Set_Digits (T : Long_Long_Unsigned) is
  99.       begin
  100.          if T >= BU then
  101.             Set_Digits (T / BU);
  102.             P := P + 1;
  103.             S (P) := Hex (T mod BU);
  104.          else
  105.             P := P + 1;
  106.             S (P) := Hex (T);
  107.          end if;
  108.       end Set_Digits;
  109.  
  110.    --  Start of processing for Set_Image_Based_Long_Long_Unsigned
  111.  
  112.    begin
  113.  
  114.       if B >= 10 then
  115.          P := P + 1;
  116.          S (P) := '1';
  117.       end if;
  118.  
  119.       P := P + 1;
  120.       S (P) := Character'Val (Character'Pos ('0') + B mod 10);
  121.  
  122.       P := P + 1;
  123.       S (P) := '#';
  124.  
  125.       Set_Digits (V);
  126.  
  127.       P := P + 1;
  128.       S (P) := '#';
  129.  
  130.       --  Add leading spaces if required by width parameter
  131.  
  132.       if P - Start < W then
  133.          F := P;
  134.          P := Start + W;
  135.          T := P;
  136.  
  137.          while F > Start loop
  138.             S (T) := S (F);
  139.             T := T - 1;
  140.             F := F - 1;
  141.          end loop;
  142.  
  143.          for J in Start + 1 .. T loop
  144.             S (J) := ' ';
  145.          end loop;
  146.       end if;
  147.  
  148.    end Set_Image_Based_Long_Long_Unsigned;
  149.  
  150. end System.Img_LLB;
  151.